#!/usr/bin/env perl
$language="python";
$debug=0;
$cxx="";
while($ARGV[0] =~ /^-/o){
   $arg=shift @ARGV;
   if($arg =~ /^-perl/oi){
      $language="perl5";
   }elsif($arg =~ /^-py/oi){
      $language="python";
   }elsif($arg =~ /^-tcl/oi){
      $language="tcl8";
   }elsif($arg eq "-d"){
      $debug=1;
   }elsif($arg eq "-c++"){
      $cxx="-c++";
   }
}

$ignored=0;
$inline=0;
while(<>){
   if(/%inline/o && !$ignore){
      $inline=1;
      $last_inline=$ind;
   }
   if(/%\{/o){
      $ignored=1;
   }
   if(m|/\*|o){
      $ignored=1;
   }
   if(/%\}/o || m|\*/|o){
      $ignored=0; $inline=0;
   }
   if($ignored && !$inline){ push @lines,$_; next;}

   if(/^\s*\%\s*callback\b/o || /^\s*(\w[\w\&\s\*]*)\s*\(\s*\*\s*(\w+)\s*\)\s*\(/o){
      while($_ !~ /;\s*$/mo){ chop; $_.=<>; }
      if($_ !~ /%callback/o){ $_="%callback $_"; }
   }
   push @lines,$_;
}

if($debug){
   open(F,">tmp.i");
   print F join("",@lines);
   close(F);
}

$ind=0;
$ignored=0;
$inline=0;
foreach (@lines){
   if(/%inline/o && !$ignore){
      $inline=1;
      $last_inline=$ind;
   }
   if(/%\{/o){
      $ignored=1;
   }
   if(m|/\*|o){
      $ignored=1;
   }
   if(/%\}/o || m|\*/|o){
      $ignored=0; $inline=0;
   }
   if($ignored && !$inline){ $ind++; next;}

#   if(/^\s*\%\s*callback\s+(.*?)\s*?(\w+)\s*\(\s*(.*?)\s*\)/o){
   if(/^\s*%callback\s+(.*?)\s*\(\s*\*\s*(\w+)\s*\)\s*\(\s*(.*?)\s*\)/o){
      $ret=$1; $func=$2; $args=$3;
      if($args eq "void"){ $args="";}
      if($inline){
         $orgline=$_; $orgline =~ s/%callback//o;
         $orgline="%{\n$orgline%}\n";
      }else{ $orgline="";}
      if($ret =~ s/\bextern\b//o){}
      if($ret =~ s/static//o){ $static="static";}else{ $static="";}
      if($ret =~ /\bvoid\b\s*$/o){ 
         $retval="";
         $mk_ret_type="";
      }else{ 
         $retval="ret";
         $mk_ret_type="$ret ret,";
      }
      @arglist=split(/\s*,\s*/,$args);
      fix_args(@arglist);
      get_ret($ret);
      $count=0;
      @tuple=();
      $str1="";
      $args=join(",",@arglist);
      foreach $arg(@arglist){
         $arg =~ /^(.+)\b(\w+)\s*$/o;
         get_argin($1,$2,$count);
         $str1.=join("",@in_lines);
         push @tuple,"arg$count"; 
         $count++;
      }

      if($language eq "perl5"){
#---------------------------Perl5------------------------------------
      $str=<<"END";
%{
static SV* PlCallBack_$func=0;
$static $ret _cbwrap_$func\($args){
    int argvi = 0;
    SV *sv;
$ret_decl
    dSP;
    if(!PlCallBack_$func)return 0;
    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
$str1
    PUTBACK; 
    perl_call_sv(SvRV(PlCallBack_$func),G_EVAL|G_SCALAR);
    SPAGAIN;
    sv=POPs;
@{[join("\n    ",@ret_lines)]}
    PUTBACK;
    FREETMPS;
    LEAVE;
    return $retval;
}
%}
#if defined(SWIGPERL)
%typemap(in) SV*{ \$1=\$input;}
#endif
%rename($func) void register_$func(SV *plfunc);
%{
void register_$func(SV* plfunc){
    if(!SvROK(plfunc) || SvTYPE(SvRV(plfunc))!=SVt_PVCV){
       croak("Not a Callback %_ for register_$func",plfunc);
    }
    if(PlCallBack_$func)SvREFCNT_dec(PlCallBack_$func);
    PlCallBack_$func=plfunc;
    SvREFCNT_inc(plfunc);
}
%}
END

      }elsif($language eq "tcl8"){
#---------------------------Tcl8------------------------------------
      $str=<<"END";
%{
static Tcl_Obj* TclCallBack_$func=0;
$static $ret _cbwrap_$func\($args){
$ret_decl
    Tcl_Obj *@{[join(", *",@tuple)]};
    Tcl_Interp *interp=static_interp;
    Tcl_Obj *cmdPtr;

    if(!TclCallBack_$func)return 0;
    cmdPtr=Tcl_DuplicateObj(TclCallBack_$func);
    Tcl_IncrRefCount(cmdPtr);
$str1
    if (Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) {
        Tcl_BackgroundError(interp);
    }
    { 
      Tcl_Obj *o=Tcl_GetObjResult(interp);
      Tcl_GetIntFromObj(interp,o,&$retval);
    }
    Tcl_DecrRefCount(cmdPtr);
    return $retval;
}
%}
%rename($func) void register_$func(Tcl_Obj *pyfunc);
%{
void register_$func(Tcl_Obj *tclfunc){
    if(TclCallBack_$func)Tcl_DecrRefCount(TclCallBack_$func);
    TclCallBack_$func=tclfunc;
    Tcl_IncrRefCount(tclfunc);
}
%}
END

      }else{ # for Python
#---------------------------Python------------------------------------
      $str=<<"END";
%{
static PyObject* PyCallBack_$func=0;
$static $ret _cbwrap_$func\($args){
    PyObject *arglist,*result;
$ret_decl
    PyObject *@{[join(", *",@tuple)]};
    if(!PyCallBack_$func)return 0;
$str1
    arglist=Py_BuildValue("(@{[map {"O"} @arglist]})",@{[join(",",@tuple)]});
    result=PyEval_CallObject(PyCallBack_$func,arglist);
    Py_XDECREF(arglist);
    ret=(int)PyInt_AsLong(result);
    Py_XDECREF(result);
    return $retval;
}
%}
%rename($func) void register_$func(PyObject *pyfunc);
%{
void register_$func(PyObject *pyfunc){
    if (!PyCallable_Check(pyfunc)) {
      PyErr_SetString(PyExc_TypeError, "Need a callable object!");
      return;
    }
    if(PyCallBack_$func)Py_DECREF(PyCallBack_$func);
    PyCallBack_$func=pyfunc;
    Py_INCREF(pyfunc);
}
%}
END
      } # end of if $language
      $str.=<<"END";
$orgline
%init %{
    $func(_cbwrap_$func);
%}
END
      if($inline){
         $lines[$ind]="";
         $lines[$last_inline]=$str.$lines[$last_inline];
      }else{
         $lines[$ind]=$str;
      }
   }
   $ind++;
}
print @lines;

sub fix_args{
   my $i=0;
   my $arg;
   for $arg(@_){
      if($arg =~ /^\s*(const|struct)?\s*\w+\s*$/o || $arg =~ /[^\w\s]\s*$/o){
         $arg.=" _param$i";
      }
      $i++;
   }   
}

sub get_ret{
   my ($type)=@_;
   open(F,">./cbtmp.i");
   print F @lines[0..$ind-1];
   print F "void CALLBACK($type);\n";
   print F grep { $_ !~ /^\s*\%\s*callback\b/o } @lines[$ind+1..$#lines];
   close(F);
   system "swig $cxx -$language $options cbtmp.i";
   open(F,"cbtmp_wrap.c");
   while(<F>){  last if /_wrap_CALLBACK/o; }
   while(<F>){
      if(/\bresultobj\b/o){ next;
      }elsif(/arg0\b/o){ 
         s/\barg0\b/ret/og; 
         $ret_decl=$_; 
         last;
      }
   }  
   if($language eq "perl5"){
      while(<F>){ last if /^\s*croak/o;}
   }
   @ret_lines=();
   while(<F>){
      last if /^\s*CALLBACK\(/o;
      if(/^\s*$/o){next;}
      s/\barg0\b/ret/og;
      s/return\b/return ($type)/o;
      if($language eq "perl5"){ s/\bST\(.+?\)/sv/go;}
      push @ret_lines,$_;
   }
   close(F);
   if(!$debug){
      unlink("cbtmp.i");
      unlink("cbtmp_wrap.c");
   }
}

sub get_argin{
   my ($type,$var,$i)=@_;
   @in_lines=();
   open(F,">./cbin.i");
   print F @lines[0..$ind-1];
   print F "$type CALLBACK();\n";
   print F grep { $_ !~ /^\s*\%\s*callback\b/o } @lines[$ind+1..$#lines];
   close(F);
   system "swig $cxx -$language $options cbin.i";
   open(F,"cbin_wrap.c");
   while(<F>){ last if /\)\s*CALLBACK\(\);\s*$/o; }
   while(<F>){
      last if /^\s*return resultobj/o ||  /^\s*XSRETURN\(/o || /^\s*return\s+TCL_OK/o;
      s/\bresult\b/$var/og;
      s/\bresultobj\b/arg$i/og;
      if($language eq "perl5"){ s/\bST\(.+?\)/sv/go;}
      elsif($language eq "tcl8"){  
         if(s/Tcl_SetObjResult\(interp,/arg$i=/o){
            s/\);/;/o;
         }
         s/tcl_result\b/arg$i/go;
      }
      push @in_lines,$_; 
   }
   if($language eq "perl5"){push @in_lines,"    XPUSHs(sv);\n";}
   elsif($language eq "tcl8"){
      push @in_lines,"    Tcl_ListObjAppendElement(interp, cmdPtr, arg$i);\n";}
   close(F);
   if(!$debug){
      unlink("cbin.i");
      unlink("cbin_wrap.c");
   }
}
